home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 21 / Cream of the Crop 21 (Terry Blount) (October 1996).iso / database / tickle15.zip / TKLPACK.PPS < prev    next >
Text File  |  1996-08-02  |  7KB  |  274 lines
  1. ; TKLPACK.PPS - Database Packing Utility - Version 1.0
  2. ;               This program checks usersnames in TICKLE.DBF
  3. ;               then checks the appropriate PCBNDX.? file to
  4. ;               see if the name exists.  If not, the record
  5. ;               is flagged for deletion.
  6. ;
  7. ; Written by Dan Shore
  8. ;
  9. ;--------------------------------------------------------------------------
  10.  
  11. STRING name_hold, ndx_path, first_letter, ndx_file, ndx_user_name, tkltext
  12. STRING user_input, reg_code, hold, parm1
  13. LONG ndx_size, seek_record, value
  14. FLOAT high_num, low_num, rec_num
  15. INT x, user_rec_num, current_record, high_record, low_record
  16. INT y, cmd_line_count, deleted_users, row, col
  17. BOOLEAN done, name_found, registered, found_files
  18.  
  19. :START_MAIN
  20.  
  21.    tkltext = PPEPATH() + "TKLTEXT" + LANGEXT()
  22.  
  23.    CLS
  24.    NEWLINES 3
  25.    PRINTLN READLINE (tkltext,59)
  26.    NEWLINES 2
  27.    DELAY 18
  28.  
  29.    PRINT READLINE (tkltext,60)
  30.    GOSUB READ_CONFIG
  31.    PRINTLN READLINE (tkltext,61)
  32.    NEWLINE
  33.  
  34.    PRINT READLINE (tkltext,62)
  35.    GOSUB MAKE_BACKUP_FILES
  36.    PRINTLN READLINE (tkltext,61)
  37.    NEWLINE
  38.  
  39.    PRINT READLINE (tkltext,63)
  40.    GOSUB OPEN_DATABASE
  41.    IF (DERR(0)) THEN
  42.      SPRINTLN READLINE (tkltext,64)
  43.      LOG "Cannot open TICKLE.DBF (DataBase) in EXCLUSIVE mode - Aborting", FALSE
  44.      GOTO EXIT_PROG
  45.    END IF
  46.  
  47.    GOSUB OPEN_INDEX
  48.    IF (DERR(0)) THEN
  49.      SPRINTLN READLINE (tkltext,4)
  50.      LOG "Cannot open TICKLE.NDX (Index) - Aborting", FALSE
  51.      GOTO EXIT_PROG
  52.    END IF
  53.    PRINTLN READLINE (tkltext,61)
  54.    NEWLINE
  55.  
  56.  
  57.    PRINTLN READLINE (tkltext,65)
  58.    NEWLINE
  59.    DELAY 36
  60.    GOSUB CHECK_NAMES
  61.  
  62.    IF (deleted_users > 0) THEN
  63.      NEWLINES 2
  64.      PRINTLN READLINE (tkltext,66)
  65.      NEWLINES 2
  66.      DTOP 0
  67.      DPACK 0
  68.    END IF
  69.    FPUTLN 2, "Total Number of Records in Database After Pack  : ", DRECCOUNT(0)
  70.    FPUTLN 2
  71.    FPUTLN 2, "Total Users Deleted : ", deleted_users
  72.    FPUTLN 2, "     Time Completed : ", TIME()
  73.    FCLOSE 2
  74.    NEWLINE
  75.    PRINTLN READLINE (tkltext,67)
  76.    NEWLINE
  77.    GOTO EXIT_PROG
  78.    END
  79.  
  80. ;
  81. ;
  82. ;
  83. :CHECK_NAMES
  84.  
  85.    DTOP 0
  86.    PRINTLN READLINE (tkltext,68)
  87.    NEWLINE
  88.    FAPPEND 2, PPEPATH()+PPENAME()+".log", O_WR, S_DN
  89.    FPUTLN 2
  90.    FPUTLN 2
  91.    FPUTLN 2, "========================================================================"
  92.    FPUTLN 2
  93.    FPUTLN 2, "Tickle File Packing Program - Version 1.10"
  94.    FPUTLN 2, "Written by Dan Shore - SysOp - The Shoreline BBS"
  95.    FPUTLN 2
  96.    FPUTLN 2, "      Date of Pack : ", DATE()
  97.    FPUTLN 2, "Start Time of Pack : ", TIME()
  98.    FPUTLN 2
  99.    FOR x = 1 TO DRECCOUNT(0)
  100.      STARTDISP FNS
  101.      DGO 0, x
  102.      name_hold = DGET (0,DNAME(0,1))
  103.      first_letter = LEFT(name_hold,1)
  104.      IF (first_letter < "A") first_letter = "A"
  105.      IF (first_letter > "Z") first_letter = "Z"
  106.      FPUT 2, "Processing Username: ", name_hold
  107.      IF (!row) THEN
  108.        PRINT READLINE (tkltext,69)
  109.        row = GETX()
  110.        col = GETY()
  111.      END IF
  112.      ANSIPOS row, col
  113.      PRINT x
  114.  
  115.      GOSUB PCB_INDEX_SEARCH
  116.      found_files = FALSE
  117.      IF (parm1 = "TRUE" && name_found) GOSUB CHECK_FOR_FILES
  118.      IF (!name_found || (parm1 = "TRUE" && found_files = "FALSE")) THEN
  119.        IF (!name_found) FPUTLN 2, "Not Current User - Deleted"
  120.        IF (name_found && parm1 = "TRUE" && found_files = FALSE) FPUTLN 2, "No Files - Deleted"
  121.        DDELETE 0
  122.        INC deleted_users
  123.      ELSE
  124.        FPUTLN 2, "Current User"
  125.      END IF
  126.  
  127.    NEXT
  128.    PRINTLN "@X07"
  129.    FPUTLN 2
  130.    FPUTLN 2, "Total Number of Records in Database Before Pack : ", DRECCOUNT(0)
  131.    STARTDISP FCL
  132.    RETURN
  133.  
  134. ;
  135. ;
  136. ;
  137. :PCB_INDEX_SEARCH
  138.  
  139.    ndx_file = ndx_path + "PCBNDX." + first_letter
  140.    ndx_size = FILEINF(ndx_file, 4)
  141.  
  142.    IF (ndx_size < 27) THEN
  143.      PRINTLN READLINE (tkltext,70), ndx_file, READLINE (tkltext,71)
  144.    END IF
  145.  
  146.    high_record = ndx_size/27
  147.    low_record = 0
  148.  
  149.    FOPEN 1, ndx_file, O_RD, S_DN
  150.  
  151.    Done = FALSE
  152.    name_found = FALSE
  153.    WHILE (!Done) DO
  154.       high_num = high_record
  155.       low_num = low_record
  156.       high_num = high_num/2
  157.       low_num = low_num/2
  158.       rec_num = high_num + low_num + .5
  159.       current_record = rec_num
  160.       seek_record = (current_record-1) * 27
  161.       FSEEK 1, seek_record, SEEK_SET
  162.       FREAD 1, user_rec_num, 2
  163.       FREAD 1, ndx_user_name, 25
  164.       IF (ndx_user_name = name_hold) THEN
  165.          name_found = TRUE
  166.          done = TRUE
  167.       ELSE IF (high_record - low_record < 2) THEN
  168.               done = TRUE
  169.       ELSE IF (ndx_user_name < name_hold) THEN
  170.               low_record = current_record
  171.       ELSE IF (ndx_user_name > name_hold) THEN
  172.               high_record = current_record
  173.       END IF
  174.    ENDWHILE
  175.    FCLOSE 1
  176.    RETURN
  177.  
  178. ;
  179. ;  Make Backup files of database and index files
  180. ;
  181. :MAKE_BACKUP_FILES
  182.  
  183.    COPY PPEPATH()+"TICKLE.DBF", PPEPATH()+"TICKLE.DBK"
  184.    COPY PPEPATH()+"TICKLE.NDX", PPEPATH()+"TICKLE.NBK"
  185.    RETURN
  186.  
  187. ;
  188. ; Open configuration file and read
  189. ; to find the path to the PCBNDX.? files
  190. ;
  191. :READ_CONFIG
  192.  
  193.    FOPEN 1, PPEPATH()+PPENAME()+".cfg",O_RD,S_DN
  194.    FGET 1, ndx_path
  195.    FGET 1, parm1
  196.    IF (FERR(1)) parm1 = "FALSE"
  197.    FCLOSE 1
  198.    IF (parm1 != "TRUE") parm1 = "FALSE"
  199.    ndx_path = TRIM (ndx_path," ")
  200.    IF (RIGHT(ndx_path,1) != "\") ndx_path = ndx_path + "\"
  201.    RETURN
  202.  
  203. '
  204. '  Close the index file, the database file, and exit program
  205. '
  206. :EXIT_PROG
  207.  
  208.    DNCLOSEALL 0
  209.    DCLOSE 0
  210.    PRINTLN READLINE (tkltext,72)
  211.    NEWLINE
  212.  
  213. '   GOSUB CHECK_KEY
  214. '   IF (registered) THEN
  215. '     PRINTLN "            @X0BRegistered to: @X0E", user_input, "@X07"
  216. '   ELSE
  217. '     NEWLINE
  218. '     PRINTLN "  *************************************************"
  219. '     PRINTLN "   [Unregistered Version] - Pausing for 5 Seconds"
  220. '     PRINTLN "  Support the Shareware Concept and Register Today"
  221. '     PRINTLN "  *************************************************"
  222. '     DELAY 90
  223. '   END IF
  224.    END
  225.  
  226. '
  227. '
  228. '
  229. ':CHECK_KEY
  230. '
  231. '   FOPEN 3, PPEPATH() + "TKL.KEY", O_RD, S_DN
  232. '   FGET 3, hold
  233. '   FGET 3, reg_code
  234. '   hold = RTRIM(hold," ")
  235. '   hold = MID(hold,INSTR(hold,":")+1,LEN(hold)-INSTR(hold,":"))
  236. '   user_input = TRIM(hold," ")
  237. '   hold = MID(reg_code,3,LEN(reg_code)-2)
  238. '   reg_code = TRIM(hold," ")
  239. '   FOR x = 1 TO LEN(user_input)
  240. '     y = S2I(MID(user_input,x,1),36)-9
  241. '     value = value + y
  242. '   NEXT
  243. '   IF (value < 0) value = value * -1
  244. '   IF (value = 0) value = value + 384
  245. '   value = value * 7914
  246. '   hold = LTRIM(STRING(value)," ")
  247. '   IF (hold = reg_code) registered = TRUE
  248. '   FCLOSE 3
  249. '   RETURN
  250.  
  251. '
  252. '  Subroutine to open/create database files
  253. '
  254. :OPEN_DATABASE
  255.  
  256.    DOPEN 0, PPEPATH()+"tickle", TRUE
  257.    RETURN
  258.  
  259. '
  260. '  Subroutine to open the username index file
  261. '
  262. :OPEN_INDEX
  263.  
  264.    IF (EXIST(PPEPATH()+"tickle.ndx")) DNOPEN 0, PPEPATH()+"tickle"
  265.    RETURN
  266.  
  267. '
  268. '
  269. '
  270. :CHECK_FOR_FILES
  271.  
  272.     IF (DGET(0,DNAME(0,2)) != "            ") found_files = TRUE
  273.     RETURN
  274.